package Stdlog::Criteria;

require 5.008;
use strict;
use warnings;
use Stdlog::Levels qw(@sorted_lvls %levels);

sub new {
    my ($pkg, $conf) = @_;
    my @stmts;

    if( $conf ){
        if( exists $conf->{facility} ){
            push @stmts, parse_facility($conf->{facility});
        }
        if( exists $conf->{package} ){
            push @stmts, parse_packages($conf->{package});
        }
        if( exists $conf->{severity} ){
            push @stmts, parse_severity($conf->{severity});
        }
        if( exists $conf->{expression} || exists $conf->{expr} ){
            push @stmts, parse_expression($conf->{expression}||$conf->{expr});
        }
        if( exists $conf->{variable} || exists $conf->{var} ){
            push @stmts, parse_variable($conf->{variable}||$conf->{var});
        }
    }
    push @stmts, '1' unless @stmts;
    my $code = 'sub{ my $args=shift; (' . join('||', @stmts) . ') ? 1 : 0; }';
    my $self = eval $code;
    
    if( $@ ){
        return undef;
    }else{
        bless $self, $pkg;
        return $self;
    }
}


sub parse_facility {
    my $facility = shift @_;
    
    if( $facility =~ m|^/.*/$| ){
        $facility = substr($facility, 1, -1);
        return "(\$0 =~ m/$facility/)";
    }else{
        return "(\$0 eq '$facility')";
    }
}


sub parse_packages {
    my $pkgs = shift @_;
    
    my @parts;
    for (split /\s*,\s*|\s+/, $pkgs){
        if( m|^/.*/$| ){
            $_ = substr($_, 1, -1);
            push @parts, "(\$args->{package} =~ m/$_/)";
        }elsif( m|^\w+(?:::\w+)*$| ){
            push @parts, "(\$args->{package} eq '$_')";
        }else{
            die "Invalid package directive in parse_packages ($_)\n";
        }
    }
    return @parts;
}


sub parse_severity {
    my $sevr = shift @_;
    my @lvls;
    my $sre = join('|', @sorted_lvls);
    
    for  (split /\s*,\s*|\s+/, $sevr){
        if( /^($sre)\+$/ ){
            my $min = uc $1;
            for(@sorted_lvls){
                push @lvls, $_ if $_ eq $min .. $_ eq 'FATAL';
            }
        }elsif( /^($sre)\-$/ ){
            my $max = uc $1;
            for(@sorted_lvls){
                push @lvls, $_ if $_ eq 'DEBUG' .. $_ eq $max;
            }
        }elsif( /^($sre)$/ ){
            push @lvls, uc($1);
        }else{
            die "Unknown severity config in parse_severity ($_)\n";
        }
    }
    my $mask = 0;
    $mask |= $levels{$_} for (@lvls);
    return "(\$Stdlog::Levels::levels{\$args->{severity}} & $mask)";
}


sub parse_expression {
    my $expr = shift;
    my $rt = ref $expr;
    die "Bad reference to parse_expression\n"
        if $rt && $rt ne 'ARRAY';
    my @parts;
    $expr = [$expr] unless $rt eq 'ARRAY';
    for my $e (@$expr){
        push @parts, "($expr)";
    }
    return @parts;
}


sub parse_variable {
    my $vars = shift;
    my $rt = ref $vars;
    die "Bad reference to parse_variable\n"
        if $rt && $rt ne 'ARRAY';
    my @stmts;
    $vars = [$vars] unless $rt eq 'ARRAY';
    for my $pair (@$vars){
        for  (split /\s*,\s*/, $pair){
            my ($name, $val) = split /\s*=>\s*/, $_;
            
            if( $val =~ m|^/.*/$| ){
                $val = substr($val, 1, -1);
                push @stmts, "(\$name =~ m/$val/);";
            }else{
                push @stmts, "(\$name eq '$val');";
            }
        }
    }
    return @stmts;
}


1;
__END__

=head1 NAME

Stdlog::Criteria -- functions to formatted log output

=head1 SYNOPSIS

  use Stdlog::Criteria;
  
  

=head1 DESCRIPTION

Criteria objects are blessed code references and are used to determine if the
associated logger should write to its logging target.

=head2 Criteria Options

=over 8

=item * facility

=item * severity

=item * package

=item * expression

=back

=head1 CLASS METHODS

=head2 Stdlog::Criteria->new($conf)

Creates a criteria object and returns a reference to it


=head2 Criteria Calling Convention

  $criteria->($severity, $package, $options);


=head1 OBJECT METHODS

None, call the object directly (i.e. $criteria->(@args))

=head1 EXPORTS

Nothing.

=head1 SEE ALSO

L<Stdlog>, L<Stdlog::Logger>

=head1 AUTHOR

Robert Mah E<lt>rmah@pobox.comE<gt>


=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007 by Robert Mah

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.

=cut
